Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/chap02/howto01/drwsutl2.pas

Pascal/Delphi Source File | 1996-03-05 | 41.8 KB | 1,167 lines

unit Drwsutl2;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl ;

type
  TFileWorkBench = class( TComponent )
  public
    GlobalError        : Integer;  { This is used by FMXUCopyFile for er code }
    GlobalErrorType    : Integer;  { This holds the Operation code            }
    function ForceTrailingBackSlash( const TheFileName : String ) : String;
    function StripNonRootTrailingBackSlash(
              const TheFileName : String ) : String;
    procedure GetFileAttributes( TheFile : String; var IsDirectory , IsArchive ,
                IsVolumeID , IsHidden , IsReadOnly , IsSysFile : Boolean );
    procedure FMXUCopyFile(const FileName, DestName: String);
    function CopyFile( TargetPath ,
               DestinationPath : String ) : Boolean;
    procedure ChangeTheDirectory( NewPath : String );
    procedure ChangeTheDriveAndDirectory( NewDrive : Integer );
    procedure CopyTheFile( OldPath , NewPath : String );
    procedure MoveTheFile( OldPath , NewPath : String );
    procedure DeleteTheFile( ThePath : String );
    procedure RenameTheFile( OldPath , NewName : String );
    procedure CreateNewDirectory( NewPath : String );
    procedure RemoveDirectory( ThePath : String );
  end;
  TFileIconPanel = class( TPanel )
  private
    { Private declarations }
    FHighlightColor : TColor;                 { This holds bright edge bevel }
    FShadowColor    : TColor;                 { This holds dark edge bevel   }
    procedure TheClick( Sender : TObject );   { This holds override click    }
  protected                                   { event method procedure.      }
    { Protected declarations }
    procedure Paint; override;                { This allows custom painting  }
  public
    { Public declarations }
    FTheIcon : TIcon;                         { This is the display icon    }
    FTheName : String;                        { This is the filename        }
    FTheLabel : TLabel;                       { This is the display label   }
    Selected : Boolean;                       { This holds selection status }
    constructor Create(AOwner : TComponent); override; { override create    }
    procedure Initialize( PanelX              ,             { Left          }
                          PanelY              ,             { Top           }
                          PanelWidth          ,             { Width         }
                          PanelHeight         ,             { Height        }
                          PanelBevelWidth     ,             { Bevel Width   }
                          LabelFontSize         : Integer;  { Font size     }
                          PanelColor          ,             { Main color    }
                          PanelHighlightColor ,             { Bright color  }
                          PanelShadowColor    ,             { Dark color    }
                          LabelTextColor        : TColor;   { Text color    }
                          TheFilename         ,             { Filename      }
                          LabelFontName         : String;   { Font name     }
                          LabelFontStyle        : TFontStyles;  { Font style}
                          ExtraData             : Integer       );  { Drive }
    destructor Destroy; override;             { override destroy to free    }
  end;
  TFileIconPanelScrollBox = class( TScrollBox )
  public
    { Public methods and data }
    TheFWB              : TFileWorkBench; { Used for file manipulation         }
    IconsNeedRefreshing : Boolean;                   { Flag to redo display    }
    TheIconSize        : Integer;   { Holds Individual Icon size               }
    TheIconSpacing     : Integer;   { Holds total icon footprint               }
    MaxIconsInARow     : Integer;   { Set for screen size.                     }
    TheStoredHandle    : HWnd;
    procedure Update;                                { Called to reset display }
    constructor Create( AOwner : TComponent ); override;  { Override inherited }
    procedure ClearTheFIPs;                          { Clears the FIPs safely  }
    procedure AddDriveIcons( var XCounter , YCounter : Integer ); { Add drives }
    procedure GetColorsForFileIcon( TheFile : String;
               var BC , HC , SC , TC : TColor );
    procedure GetIconsForEntireDirectory( TargetPath  : String );
    function GetNextSelection( SourceDirectory : String;
              var CurrentItem : Integer ) : String;
  end;

  { This procedure spaces out the bitbtn components on a tpanel }
  procedure SpacePanelButtons( WhichPanel : TPanel );
  procedure GetIconForFile( TheName : String; var TheIcon : TIcon );

implementation
uses DRWSUTL1;
{$R DRWSUTL2.RES}                 { Import custom resource file }

{ This procedure gets an icon for a file using FindExecutable  }
{ and ExtractIcon. (assumes file/dir is passed)                }
procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
var TheExt           : String; { File extension holder }
    TheOtherPChar  ,           { Windows ASCIIZ string }
    ThePChar         : PChar;  { Windows ASCIIZ string }
    Dummy : Word;
begin
  { Check for directory and if so get directory icon from RES file }
  if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  begin
    { Set up the PChar to communicate with Windows }
    GetMem( TheOtherPChar , 255 );
    { Convert Pascal-style string to ASCIIZ Pchar }
    StrPCopy( TheOtherPChar , 'DIRECTORY' );
    { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
    TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
    { Release memory from PChar }
    FreeMem( TheOtherPChar , 255 );
    { Leave }
    exit;
  end;
  { Assume archive file; get its extension }
  TheExt := Uppercase( ExtractFileExt( TheName ));
  { If not an executable/image file then use FindExecutable to get icon }
  if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
      ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  begin
    { Grab three chunks of memory }
    GetMem( ThePChar , 255 );
    { Set up the name and its directory in Windows string formats }
    StrPCopy( ThePChar, TheName );
    Dummy := 65535;
    {**** Windows 95 Specialized call ****** }
    TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
    if TheIcon.Handle = 0 then
    begin
      GetMem( TheOtherPChar , 255 );
      StrPCopy( TheOtherPChar , 'NOICON' );
      TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
      FreeMem( TheOtherPChar , 255 );
      exit;
    end;
    FreeMem( ThePChar , 255 );
  end
  else
  { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  begin
    GetMem( ThePChar , 255 );
    StrPCopy( ThePChar , TheName );
    { Try to get first icon for file }
    Dummy := 65535;
    TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
    FreeMem( ThePChar , 255 );
    { If handle is 0 invalid icon format so use default from RES file }
    if TheIcon.Handle = 0 then
    begin
      GetMem( TheOtherPChar , 255 );
      StrPCopy( TheOtherPChar , 'NOICON' );
      TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
      FreeMem( TheOtherPChar , 255 );
      exit;
    end;
  end;
end;

{ This procedure spaces out the bitbtn components on a tpanel }
procedure SpacePanelButtons( WhichPanel : TPanel );
var TheCalculatedSpacing     ,            { Holds primary spacing }
    TheFullCalculatedSpacing   : Integer; { Holds full spacing    }
    Counter_1                  : Integer; { Loop counter          }
    TotalIBs                   : Integer; { Gets total buttons    }
begin
  { Set up spacing values }
  TotalIBs := WhichPanel.ControlCount;
  TheCalculatedSpacing := (( WhichPanel.Width - 6 - ( TotalIbs * 49 ))
   div ( TotalIbs + 1 ));
  TheFullCalculatedSpacing := TheCalculatedSpacing + 49;
  { Loop through all imported buttons and set their Left values }
  for Counter_1 := 1 to WhichPanel.ControlCount do
  begin
    if Counter_1 = 1 then
    begin
      TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
       TheCalculatedSpacing;
    end
    else
    begin
      TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
       (( Counter_1 - 1 ) * TheFullCalculatedSpacing ) + TheCalculatedSpacing;
    end;
  end;
end;

{ This procedure does a fully error-trapped change directory }
procedure TFileWorkBench.ChangeTheDirectory( NewPath : String );
var CurrentDirectory : String;
begin
  if NewPath = '..' then
  begin { Back up one level }
    { Find the current directory }
    GetDir( 0 , CurrentDirectory );
    { Use EFP to move up one level }
    CurrentDirectory := ExtractFilePath( CurrentDirectory );
    { Strip trailing \ if not root }
    CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
    { Try the change to the new drive }
    ChDir( CurrentDirectory );
  end
  else
  begin { Change to explicit path }
    { Get target directory path }
    CurrentDirectory := NewPath;
    { Strip trailing \ if not root }
    CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
    { Try the change to the new drive }
    ChDir( CurrentDirectory );
  end;
end;

{ This procedure does a fully error-trapped change directory }
procedure TFileWorkBench.ChangeTheDriveAndDirectory( NewDrive : Integer );
var CurrentDirectory : String;
begin
  { Find the working directory on new drive }
  GetDir( NewDrive , CurrentDirectory );
  { Try the change to the new drive }
  ChDir( CurrentDirectory );
end;

{ This procedure copies a single file with error trapping }
procedure TFileWorkBench.CopyTheFile( OldPath , NewPath : String );
begin
  { If Copyfile returns false an error occurred }
  CopyFile( OldPath , NewPath + ExtractFileName( OldPath ));
end;

{ This procedure moves a file by copying and delete it }
procedure TFileWorkBench.MoveTheFile( OldPath , NewPath : String );
var AResult : Boolean; { Internal data flag }
begin
  { If Copyfile returns false an error occurred }
  AResult := CopyFile( OldPath , NewPath +
    ExtractFileName( OldPath ));
  { After valid copying, delete source file }
  if AResult then
  begin
    {***** WIN 95 CHANGE!!! *****}
    SysUtils.DeleteFile( OldPath );
  end;
end;

{ This procedure safely deletes a single file }
procedure TFileWorkBench.DeleteTheFile( ThePath : String );
begin
  {***** WIN 95 CHANGE!!! *****}
  SysUtils.DeleteFile( ThePath );
end;

{ This procedure renames a file with full error trapping }
procedure TFileWorkBench.RenameTheFile( OldPath , NewName : String );
begin
  RenameFile( OldPath , NewName );
end;

{ This procedure creates a new directory with full error trapping }
procedure TFileWorkBench.CreateNewDirectory( NewPath : String );
begin
  Mkdir( NewPath );
end;

{ This procedure remove a directory with full error trapping }
procedure TFileWorkBench.RemoveDirectory( ThePath : String );
begin
  Rmdir( ThePath );
end;

{ This is a generic copy routine taken from Delphi sample code }
{ It has been edited to return viable error codes!             }
procedure TFileWorkBench.FMXUCopyFile(const FileName, DestName: String);
var
  CopyBuffer: Pointer; { buffer for copying }
  BytesCopied: Longint;
  Source, Dest: Integer; { handles }
const
  ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
  GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  if Source < 0 then
  begin  { error creating source file }
    GlobalErrorType := 1;
    GlobalError := -IOResult;
    if GlobalError = 0 then GlobalError := -157;
    FreeMem( CopyBuffer, ChunkSize );
    exit;
  end;
  Dest := FileCreate(DestName); { create output file; overwrite existing }
  if Dest < 0 then
  begin  { error creating destination file }
    FileClose( Source );
    GlobalErrorType := 2;
    GlobalError := -IOResult;
    if GlobalError = 0 then GlobalError := -159;
    FreeMem( CopyBuffer , ChunkSize );
    exit;
  end;
  {$I-}
  repeat
    BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk}
    if BytesCopied > 0 then { if we read anything... }
    FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  until BytesCopied < ChunkSize; { until we run out of chunks }
  {$I+}
  GlobalError := -IOResult;  { get any error code which happens during copying }
  FileClose(Dest); { close the destination file }
  FileClose(Source); { close the source file }
  FreeMem(CopyBuffer, ChunkSize); { free the buffer }
end;

{ This function calls the sample Copy code and handles errors }
function TFileWorkBench.CopyFile( TargetPath ,
          DestinationPath : String ) : Boolean;
begin
  { Set global error value to no error }
  GlobalError := 0;
  { Call the sample procedure to do the copy }
  FMXUCopyFile( TargetPath, DestinationPath );
  { If no error return true else return false }
  if GlobalError < 0 then CopyFile := false else
   CopyFile := true;
end;

{ This procedure sets the imported booleans to the file's attributes }
procedure TFileWorkBench.GetFileAttributes( TheFile : String; var IsDirectory ,
           IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
            IsSysFile : Boolean );
var TheResult : Integer; { Traps for error code on VolumeID }
begin
  { Clear the imported flags for default }
  IsDirectory := false;
  IsArchive := false;
  IsVolumeID := false;
  IsHidden := False;
  IsReadOnly := false;
  IsSysFile := false;
  { Make the Dos call }
  TheResult := FileGetAttr( TheFile );
  if TheResult < 0 then
  begin
    { Volume ID returns -2 (?) }
    IsVolumeID := true;
    { It has no other properties }
    exit;
  end;
  { Use AND test to set all other properties }
  if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
end;

{ This function makes sure a pathname has a trailing \ }
function TFileWorkBench.ForceTrailingBackSlash(
          const TheFileName : String ) : String;
var TempString : String;  { Used to hold function result }
begin
  { If no trailing \ add one (root will already have one.) }
  if TheFileName[ Length( TheFileName ) ] <> '\' then
   TempString := TheFileName + '\' else TempString := TheFileName;
  { Return modified or non-modified string }
  ForceTrailingBackslash := TempString;
end;

{ This function makes sure a non-root dir has no trailing \ }
function TFileWorkBench.StripNonRootTrailingBackSlash(
          const TheFileName : String ) : String;
var TempString : String ; { Used to hold function result }
begin
  { Default is no change }
  TempString := TheFileName;
  { If not root then }
  if Length( TheFileName ) > 3 then
  begin
    { If has a trailing backslash remove it }
    if TheFileName[ Length( TheFileName )] = '\' then
    begin
      TempString := Copy( TheFileName , 1 ,
       Length( TheFileName ) - 1 );
    end;
  end;
  { Export the final result }
  StripNonRootTrailingBackSlash := TempString;
end;

{ Create method for FIP                                }
constructor TFileIconPanel.Create( AOwner : TComponent );
begin
  { call inherited -- VITAL! }
  inherited Create( AOwner );
  { create icon and label components, making self owner/displayer }
  FTheIcon := TIcon.Create;
  FTheLabel := TLabel.Create( Self );
  FThelabel.Parent := Self;
  { Set own and labels mouse methods to stored methods }
  OnClick := TheClick;
  FTheLabel.OnClick := TheClick;
  { Set alignment and autosize properties of the label }
  FTheLabel.Autosize := false;
  FTheLabel.Alignment := taCenter;
  { Set selected to false }
  Selected := false;
end;

{ Initialization method for FIP                                         }
procedure TFileIconPanel.Initialize( PanelX              ,
                                     PanelY              ,
                                     PanelWidth          ,
                                     PanelHeight         ,
                                     PanelBevelWidth     ,
                                     LabelFontSize         : Integer;
                                     PanelColor          ,
                                     PanelHighlightColor ,
                                     PanelShadowColor    ,
                                     LabelTextColor        : TColor;
                                     TheFilename         ,
                                     LabelFontName         : String;
                                     LabelFontStyle        : TFontStyles;
                                     ExtraData             : Integer );

var TheLabelHeight ,             { Holder for label pixel height }
    TheLabelWidth    : Integer;  { Holder for label pixel width  }
    TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
begin
  { Set the basic properties based on imported parameters }
  Left := PanelX;
  Top := PanelY;
  Width := PanelWidth;
  Height := PanelHeight;
  Color := PanelColor;
  BevelWidth := PanelBevelWidth;
  FHighlightColor := PanelHighlightColor;
  FShadowColor := PanelShadowColor;
  FTheName := TheFilename;
  { If the ExtraData field is non-0 then a drive is being sent in }
  if ExtraData <> 0 then
  begin
    { Use the data field value to determine which icon to get from RES file }
    case ExtraData of
      1 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'FLOPPY35' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      2 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'FIXEDHD' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      3 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'NETWORKHD' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      4 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'CDROM' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      5 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'RAM' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
    end;
    { The FileNme property is already set up for the caption; use directly }
    FTheLabel.Caption := TheFilename;
    { Set up the hint for later use (make sure to set ShowHint) }
    Hint := 'Change to ' + TheFileName;
    ShowHint := true;
    { Set up all imported label properties and center it for drawing }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end
  else
  begin
    { A file or directory has been sent in; use GetIconForFile to obtain an }
    { icon either from the file, its owner, or a RES file default.          }
    GetIconForFile( FTheName , FTheIcon );
    { Check for the Backup caption and set it specially }
    if ExtractfileName( FThename ) = '..' then
    begin
      FTheLabel.Caption := '..';
      Hint := 'Up One Level';
    end
    else
    begin
      { Otherwise just get the filename for the label caption }
      { And the full path for the hint (used later.)          }
      FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
      Hint := FTheName;
    end;
    { Activate showhint so hints are seen }
    ShowHint := true;
    { Set label properties with imported values and center for display }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end;
end;

{ Destroy method for FIP }
destructor TFileIconPanel.Destroy;
begin
  { free component resources }
  FTheIcon.Free;
  FTheLabel.Free;
  { call inherited -- VITAL! }
  inherited Destroy;
end;

{ TheClick method for FIP; used for event responses }
procedure TFileIconPanel.TheClick( Sender : TObject );
begin
  { Currently ignore drive clicks }
  if Pos( 'DRIVE' , FTheName ) > 0 then exit;
  { Flip status of bevels }
  if BevelOuter = bvRaised then BevelOuter := bvLowered else
   BevelOuter := bvRaised;
  { Flip selected variable }
  Selected := not Selected;
  { Set redisplay }
  Invalidate;
end;

{ Paint method for FIP; overrides normal paint }
procedure TFileIconPanel.Paint;
var
  TheOtherRect   : TRect;   { Holds clientrect   }
  TopColor     ,            { Holds bright color }
  BottomColor    : TColor;  { Holds dark color   }

{ These methods are from Borland Intl., copyright 1995 }
procedure Frame3D(    Canvas       : TCanvas;
                  var TheRect      : TRect;
                      TopColor   ,
                      BottomColor  : TColor;
                      Width        : Integer );

procedure DoRect;
var
  TopRight, BottomLeft: TPoint;
begin
  with Canvas, TheRect do
  begin
    TopRight.X := Right;
    TopRight.Y := Top;
    BottomLeft.X := Left;
    BottomLeft.Y := Bottom;
    Pen.Color := TopColor;
    PolyLine([BottomLeft, TopLeft, TopRight]);
    Pen.Color := BottomColor;
    Dec(BottomLeft.X);
    PolyLine([TopRight, BottomRight, BottomLeft]);
  end;
end;

begin
  Canvas.Pen.Width := 1;
  Dec(TheRect.Bottom); Dec(TheRect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(TheRect, -1, -1);
  end;
  Inc(TheRect.Bottom); Inc(TheRect.Right);
end;

procedure AdjustColors(Bevel: TPanelBevel);
begin
  TopColor := FHighlightColor;
  if Bevel = bvLowered then TopColor := FShadowColor;
  BottomColor := FShadowColor;
  if Bevel = bvLowered then BottomColor := FHighlightColor;
end;

{ Custom code begins here }
begin
  { Get the rectangle of the control with API/method call }
  TheOtherRect := GetClientRect;
  { draw basic rectangle with basic color }
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(TheOtherRect);
  end;
  { Set up for top "icon" frame  and draw it with frame3d }
  TheOtherRect.Right := Width;
  TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Do the same for the lower "label" frame }
  TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  TheOtherRect.Left := 0;
  TheOtherRect.Bottom := Height;
  TheOtherRect.Right := Width;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Then draw the icon using canvas draw method }
  Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
end;

{ This procedure clears a scrollbox of all FileIconPanels }
procedure TFileIconPanelScrollbox.ClearTheFIPs;
var TheComponent : TComponent;
begin
  { Note that must use while loop since component count continually }
  { decreases as removes are made!                                  }
  while ComponentCount > 0 do
  begin
    { Save the component as a generic TComponent }
    TheComponent := Components[ 0 ];
    { Call removecomponent to pull it out of the owner list for sb }
    { This avoids GPF when freeing the sb.                         }
    RemoveComponent( Components[ 0 ]);
    { Typecast the pointer and free it to release memory and res. }
    TFileIconPanel( TheComponent ).Free;
  end;
end;

{ This procedure scans for drives and obtains their type and creates file }
{ icon panels to represent them.                                          }
procedure TFileIconPanelScrollBox.AddDriveIcons( var XCounter ,
           YCounter : Integer );
type
  { This if from filectrl unit; reproduce here for completeness }
  TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
                dtRAM);
var
  DrivePC         : array[0..256] of char;
  DriveNum        : Integer;         { Used to get next drive via DOS fn   }
  IconType        : Integer;         { Used to hold icon type (defacto dt) }
  DriveChar       : Char;            { Used to hold drive letter           }
  DriveType       : TDriveType;      { Used for set-valued drive type      }
  Finished        : Boolean;         { Loop flag                           }
  TheFIP          : TFileIconPanel;  { Generic FileIconPanel variable      }
  ButtonColor   ,                    { Main panel color                    }
  ButtonHLColor ,                    { Bright panel color                  }
  ButtonSColor  ,                    { Dark panel color                    }
  Textcolor       : TColor;          { Label text color                    }

(*============================REMOVED DUE TO WINDOWS 95==================
{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed }
{  and the drive is using a CD driver                                   }

function IsCDROM(DriveNum: Integer): Boolean; assembler;
asm
  MOV   AX,1500h { look for MSCDEX }
  XOR   BX,BX
  INT   2fh
  OR    BX,BX
  JZ    @Finish
  MOV   AX,150Bh { check for using CD driver }
  MOV   CX,DriveNum
  INT   2fh
  OR    AX,AX
  @Finish:
end;

{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Check whether drive is a RAM drive.                                   }
function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
var
  TempResult: Boolean;
asm
  MOV   TempResult,False
  PUSH  DS
  MOV   BX,SS
  MOV   DS,BX
  SUB   SP,0200h
  MOV   BX,SP
  MOV   AX,DriveNum
  MOV   CX,1
  XOR   DX,DX
  INT   25h  { read boot sector }
  ADD   SP,2
  JC    @ItsNot
  MOV   BX,SP
  CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  JNE   @ItsNot
  CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  JNE   @ItsNot
  MOV   TempResult,True
  @ItsNot:
  ADD   SP,0200h
  POP   DS
  MOV   AL, TempResult
end;

{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Finds the type of a drive letter.                                     }
function FindDriveType(DriveNum: Integer): TDriveType;
begin
  Result := TDriveType(GetDriveType(DriveNum));
  if (Result = dtFixed) or (Result = dtNetwork) then
  begin
    if IsCDROM(DriveNum) then Result := dtCDROM
    else if (Result = dtFixed) then
    begin
        { do not check for RAMDrive under Windows NT }
      if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
        Result := dtRAM;
    end;
  end;
end;
==================END REMOVAL FOR WINDOWS 95===========================*)

begin
  { Set the button colors to an aquamarine color scheme for drives }
  ButtonColor := clTeal;
  ButtonHLColor := clAqua;
  ButtonSColor := clNavy;
  TextColor := clblack;
  { Set initial variables before looping for all drives }
  finished := false;
  DriveNum := 0;
  while not finished do
  begin
    { Start with no drive found }
    IconType := 0;
    { Set its letter and make it uppercase }
    DriveChar := Chr(DriveNum + ord('a'));
    DriveChar := Upcase(DriveChar);
    StrPCopy( DrivePC , DriveChar + ':\' );
    {*&&&&&&&&&&&&&&&  WIN 95 CALL  &&&&&&&&&&&&&&&&&&&*}
    DriveType := TDriveType(GetDriveType( DrivePC ));
    { Assign an icon based on the drive type; if no drive exists type is nil }
    case DriveType of
      dtFloppy  : IconType := 1;
      dtFixed   : IconType := 2;
      dtNetwork : IconType := 3;
      dtCDROM   : IconType := 4;
      dtRAM     : IconType := 5;
    end;
    { Set to check next drive letter }
    DriveNum := DriveNum + 1;
    { But if no match then out of drives so set exit flag }
    if IconType = 0 then finished := true;
    { If drive was valid then set up the new FileIconPanel on the imported }
    { Scrollbox                                                            }
    if not finished then
    begin
      { Create the FileIconPanel and set its parent for memory mgmt and display}
      TheFIP := TFileIconPanel.Create( Self );
      TheFIP.Parent := Self;
      { Call its initialize method with imported position values and the   }
      { preset color scheme, a drive caption, and a minimum font. Note the }
      { setting of the ExtraData field to non-zero; this signals a drive   }
      { rather than a file being sent in.                                  }
      TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
       (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
        7 , ButtonColor, ButtonHLColor,
       ButtonSColor , TextColor , 'DRIVE ' + DriveChar + ':' , 'MS Serif' , [] ,
       IconType );
      { Increment the column counter; if it exceeds max move to new row      }
      { Note that these are 'var' parameters and will export final position. }
      XCounter := XCounter + 1;
      if XCounter > MaxIconsInARow then
      begin
        XCounter := 1;
        YCounter := YCounter + 1;
      end;
    end;
  end;
end;

{ This procedure assigns colors to FIP's based on file attributes }
procedure TFileIconPanelScrollBox.GetColorsForFileIcon( TheFile : String;
           var BC , HC , SC , TC : TColor );
var AmADir      ,             { Booleans hold file attribs }
    AmAnArchive ,
    AmAVolumeId ,
    AmHidden    ,
    AmReadOnly  ,
    AmSystem      : Boolean;
begin
  { Make the call to internal fileworkbench to set attributes }
  TheFWB.GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
   AmHidden , AmReadOnly , AmSystem );
  { Volume ID has no subtypes }
  if AmAVolumeID then
  begin
    BC := clOlive;
    HC := clYellow;
    SC := clBlack;
    TC := clWhite;
    exit;
  end;
  { Check all directory combinations }
  if AmADir then
  begin
    BC := clNavy;
    HC := clBlue;
    SC := clBlack;
    TC := clWhite;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { One HECK of a file! }
          BC := clBlack;
          HC := clSilver;
          SC := clGray;
          TC := clWhite;
        end
        else
        begin { Dir,RO,Hid }
          BC := clMaroon;
          HC := clFuchsia;
          SC := clGreen;
          TC := clWhite;
        end;
      end
      else
      begin { Dir,Hid }
        BC := clPurple;
        HC := clFuchsia;
        SC := clBlack;
        TC := clWhite;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Dir,RO,Sys }
          BC := clMaroon;
          HC := clLime;
          SC := clGreen;
          TC := clWhite;
        end
        else
        begin { Dir,RO }
          BC := clGreen;
          HC := clLime;
          SC := clBlack;
          TC := clWhite;
        end;
      end
      else
      begin
        if AmSystem then
        begin { Dir,Sys }
          BC := clMaroon;
          HC := clRed;
          SC := clBlack;
          TC := clWhite;
        end;
      end;
    end;
  end
  else { Archive Only; check all combinations }
  begin
    BC := clSilver;
    HC := clWhite;
    SC := clGray;
    TC := clBlack;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Hid,RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clPurple;
          TC := clBlack;
        end
        else
        begin { RO,Hid }
          BC := clLime;
          HC := clFuchsia;
          SC := clMaroon;
          TC := clBlack;
        end;
      end
      else
      begin { Hid }
        BC := clFuchsia;
        HC := clWhite;
        SC := clPurple;
        TC := clBlack;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clMaroon;
          TC := clBlack;
        end
        else
        begin { RO }
          BC := clLime;
          HC := clWhite;
          SC := clGreen;
          TC := clBlack;
        end;
      end
      else
      begin
        if AmSystem then
        begin { System }
          BC := clRed;
          HC := clWhite;
          SC := clMaroon;
          TC := clBlack;
        end;
      end;
    end;
  end;
end;

{ This procedure gets all icons for an given directory, including drives and }
{ standard subdirectories. It does not get special combinations or h/ro/sys  }
procedure TFileIconPanelScrollbox.GetIconsForEntireDirectory(
            TargetPath  : String );
var Finished        : Boolean;         { Loop flag              }
    TheSR           : TSearchRec;      { Searchrecord for FF/FN }
    TheResult       : Integer;         { return variable        }
    TempPath        : String;          { path for FF/FN         }
    TheFIP          : TFileIconPanel;  { generic FIP holder     }
    RowCounter    ,                    { position in row of FIP }
    ColumnCounter   : Integer;         { position in col of FIP }
    ButtonColor   ,                    { main panel color       }
    ButtonHLColor ,                    { bright panel color     }
    ButtonSColor  ,                    { dark panel color       }
    Textcolor       : TColor;          { label text color       }
    IsADir ,                           { Variable for file attr }
    IsAnArchive ,
    IsAVolumeID,
    IsAReadOnlyFile,
    IsAHiddenFile ,
    IsASystemFile     : Boolean;
    MaxTextLength     : Integer;       { Used to safely set size}
begin
  { hide during refresh }
  Visible := false;
  { Delete the current set, if any }
  ClearTheFIPs;
  { Get the icon sizes }
  TheFIP := TFileIconPanel.Create( Self );
  TheFIP.Parent := Self;
  TheFIP.FTheLabel.Canvas.Font.Name := 'MS Serif';
  TheFIP.FTheLabel.Canvas.Font.Size := 7;
  MaxTextLength := TheFIP.FTheLabel.Canvas.TextWidth( 'COMMAND.COM' );
  TheFIP.Free;
  TheIconSize := MaxTextLength + 13;
  TheIconSpacing := TheIconSize + 5;
  { Set up maximum icons per row based on screen size }
  MaxIconsInARow := ( Screen.Width div TheIconSpacing );
  { Set up the position counters }
  RowCounter := 1;
  ColumnCounter := 1;
  { Get the drives for the current machine }
  AddDriveIcons( ColumnCounter , RowCounter  );
  { Set up the initial variables }
  Finished := false;
  TempPath := TargetPath + '*.*';
  { Make the call to FindFirst set to get any file; will return '.' }
  { so discard it.                                                  }
  FindFirst( TempPath , faAnyFile , TheSR );
  { loop through all files in the directory and look for directories }
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A 18 result means no more files so exit }
    {******  WINDOWS 95 INTRODUCES BUG!!! ******}
    {if TheResult < 0 then finished := true else}
    if TheResult <> 0 then finished := true else
    begin
      { Otherwise check for a directory attribute }
      if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
       faDirectory ) then
      begin
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { If found create a new FileIconPanel on the imported scrollbox }
        { Note sending 0 ExtraData parameter to indicate file not drive }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
         (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize ,
          3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
           TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and move to new row if past limit }
        ColumnCounter := ColumnCounter + 1;
        if ColumnCounter > MaxIconsInARow then
        begin
          ColumnCounter := 1;
          RowCounter := RowCounter + 1;
        end;
      end;
    end;
  end;
  { Set up new initialization variables }
  Finished := false;
  TempPath := TargetPath + '*.*';
  { Make needed call to FindFirst and discard '.' }
  FindFirst( TempPath , faAnyFile , TheSR );
  while not Finished do
  begin
    { Loop through file again, this time getting only archive files }
    TheResult := FindNext( TheSR );
    {******  WINDOWS 95 INTRODUCES BUG!!! ******}
    {if TheResult < 0 then finished := true else}
    { Result of 18 indicates no more files      }
    if TheResult <> 0 then Finished := true else
    begin
      { If faArchive file then add new FileIconPanel }
      TheFWB.GetFileAttributes(( Targetpath + TheSR.Name ) , IsADir ,
       IsAnArchive , IsAVolumeId , IsAHiddenFile , IsAReadOnlyFile ,
        IsASystemFile );
      if (( IsAnArchive ) and ( not IsADir )) then
      begin
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { Initialize new FileIconPanel and call initialize, sending 0 ED }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
         (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize ,
          3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
           TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and if needed row counter }
        ColumnCounter := ColumnCounter + 1;
        if ColumnCounter > MaxIconsInARow then
        begin
          ColumnCounter := 1;
          RowCounter := RowCounter + 1;
        end;
      end;
    end;
  end;
  { Reset to visible }
  Visible := true;
end;

{ Update method for FIPscrollbox }
procedure TFileIconPanelScrollBox.Update;
begin
  IconsNeedRefreshing := true;
  { Force a repaint }
  InvalidateRect( TheStoredHandle , nil , true );
end;

{ Create method for FIPScrollbox }
constructor TFileIconPanelScrollBox.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
  TheFWB := TFileWorkBench.Create( Self );
end;

{ This function returns the next selected file's name }
function TFileIconPanelScrollBox.GetNextSelection( SourceDirectory : String;
                           var CurrentItem : Integer ) : String;
var TheResult    : String;      { Holds result of function }
    TheComponent : TComponent;  { Used for typecast        }
    finished     : boolean;     { Loop control variable    }
    TheComponentCount : Integer;
begin
  TheComponentCount := ComponentCount;
  { If past end of components exit with no result }
  if CurrentItem > TheComponentCount then TheResult := '' else
  begin
    { Set loop counter and run till find match or run out }
    finished := false;
    while not finished do
    begin
      { Pull component out of the list and check it }
      TheComponent := Components[ CurrentItem - 1 ];
      { Increment counter for later }
      CurrentItem := CurrentItem + 1;
      { Do the typecast with AS }
      with TheComponent as TFileIconPanel do
      begin
        { If its selected make sure OK }
        if Selected then
        begin
          { Don't accept backup for this level of operation }
          if FTheLabel.Caption <> '..' then
          begin
            { Otherwise return the name and abort the loop }
            TheResult := FTheName;
            finished := true;
          end;
        end
        else
        begin
          { Check to see if out of components }
          if CurrentItem > TheComponentCount then
          begin
            { If so signal error and abort }
            TheResult := '';
            finished := true;
          end;
        end;
      end;
    end;
  end;
  GetNextSelection := TheResult;
end;

end.